home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / opt / analyze.scm next >
Text File  |  1995-10-13  |  11KB  |  398 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Simple code analysis to determine whether it's a good idea to
  6. ; in-line calls to a given procedure.
  7.  
  8. ; Hook into the byte code compiler.
  9.  
  10. (set-optimizer! 'auto-integrate
  11.   (lambda (stuff p)
  12.     (set-package-integrate?! p #t)
  13.     (newline)
  14.     (display "Analyzing... ") (force-output (current-output-port))
  15.     (let* ((names '())
  16.        (stuff
  17.         (map (lambda (filename+nodes)
  18.            (let ((filename (car filename+nodes))
  19.              (nodes (cdr filename+nodes)))
  20.              (set! names
  21.                (append (analyze-forms nodes p) names))
  22.              (cons filename nodes)))
  23.          stuff)))
  24.       (cond ((not (null? names))
  25.          (newline)
  26.          (display "Calls will be compiled in line: ")
  27.          (write (reverse names)))
  28.         (else
  29.          (display "no in-line procedures")))
  30.       (newline)
  31.       stuff)))
  32.  
  33. (define (analyze-forms scanned-nodes p)
  34.   (let ((inlines '()))
  35.     (for-each (lambda (node)
  36.         (let ((lhs (analyze-form node p)))
  37.           (if lhs
  38.               (set! inlines (cons lhs inlines)))))
  39.           scanned-nodes)
  40.     inlines))
  41.  
  42. (define (analyze-form node p)        ;Return LHS iff calls will be inlined.
  43.   (if (define-node? node)
  44.       (let ((form (node-form node)))
  45.     (let ((lhs (cadr form))
  46.           (rhs (caddr form)))
  47.       (let ((type (package-lookup-type p lhs)))
  48.         (if (variable-type? type)
  49.         (require "not assigned" lhs #f)
  50.         (let ((method (inlinable-rhs? rhs type p lhs)))
  51.           (if method
  52.               (begin (package-define! p lhs method)
  53.                  (if (transform? method)
  54.                  lhs
  55.                  #f))
  56.               #f))))))
  57.       #f))
  58.  
  59. (define lambda-node? (node-predicate 'lambda))
  60. (define name-node? (node-predicate 'name))
  61. (define loophole-node? (node-predicate 'loophole))
  62.  
  63.  
  64. (define (inlinable-rhs? node type p lhs)
  65.   (cond ((lambda-node? node)
  66.      (if (simple-lambda? node lhs p)
  67.          (make-inline-transform node type p lhs)
  68.          #f))
  69.     ((name-node? node)
  70.      (let ((name (node-form node)))
  71.        (if (and (require "symbol rhs" (list lhs name)
  72.               (symbol? name))
  73.             (require "rhs unassigned" (list lhs name)
  74.               (not (variable-type? (package-lookup-type p name))))
  75.             (require "definitely procedure" (list lhs name)
  76.               (procedure-type? (package-lookup-type p name))))
  77.            (make-inline-transform node type p lhs)
  78.            #f)))
  79.     ((loophole-node? node)
  80.      (inlinable-rhs? (caddr (node-form node)) type p lhs))
  81.     ((primitive-procedure-node? node)
  82.      (get-operator (cadr (node-form node))))
  83.     (else #f)))
  84.  
  85. (define primitive-procedure-node? (node-predicate 'primitive-procedure))
  86.  
  87.  
  88. ; We elect to integrate a procedure definition when
  89. ;  1. The procedure in not n-ary,
  90. ;  2. Every parameter is used exactly once and not assigned, and
  91. ;  3. The analysis phase says that the body is acceptable (see below). 
  92.  
  93. (define (simple-lambda? node id p)
  94.   (let* ((exp (node-form node))
  95.      (formals (cadr exp))
  96.      (body (caddr exp))
  97.      (var-nodes (node-ref node 'var-nodes)))
  98.     (and (require "not n-ary" id
  99.        (not (n-ary? formals)))
  100.      (require "unique references" id
  101.        (every (lambda (var-node)
  102.             (let ((lexical (node-ref var-node 'lexical)))
  103.               (and (= (lexical-reference-count lexical) 1)
  104.                (= (lexical-assignment-count lexical) 0))))
  105.           var-nodes))
  106.      (require "good analysis" id
  107.        (simple? (caddr exp)
  108.             (bind formals
  109.               (map (lambda (name)
  110.                  (make-node operator/name name))
  111.                    formals)
  112.               (package->environment p))
  113.             ret)))))
  114.  
  115. (define operator/name (get-operator 'name 'leaf))
  116.  
  117. ; --------------------
  118. ; SIMPLE? takes an alpha-converted expression and returns either
  119. ;  - #f, meaning that the procedure in which the expression occurs
  120. ;    has no chance of being fully inlinable, so we might as well give up,
  121. ;  - #t, if there's no problem, or
  122. ;  - 'empty, if there's no problem AND there are no lexical variable
  123. ;    references at or below this node.
  124. ; Foul situations are:
  125. ;  - complex quotations (we don't want to make multiple copies of them)
  126. ;  - a LAMBDA occurs (too much overhead, presumably)
  127. ;  - a call that is not to a primitive and not a tail call
  128.  
  129.  
  130. ; Main dispatch for analyzer
  131.  
  132. (define (simple? node env ret?)
  133.   ((operator-table-ref analyzers (node-operator-id node))
  134.    (node-form node)
  135.    env ret?))
  136.  
  137. (define (simple-list? exp-list env)
  138.   (if (null? exp-list)
  139.       'empty
  140.       (let ((s1 (simple? (car exp-list) env no-ret)))
  141.     (if (eq? s1 'empty)
  142.         (simple-list? (cdr exp-list) env)
  143.         (if s1
  144.         (and (simple-list? (cdr exp-list) env)
  145.              #t)
  146.         #f)))))
  147.  
  148.  
  149. ; Particular operators
  150.  
  151. (define analyzers
  152.   (make-operator-table (lambda (exp env ret?)
  153.              (simple-list? (cdr exp) env))))
  154.  
  155. (define (define-analyzer name proc)
  156.   (operator-define! analyzers name #f proc))
  157.  
  158. (define-analyzer 'literal
  159.   (lambda (exp env ret?)
  160.     (if (require "repeatable literal" #f
  161.       (simple-literal? exp))
  162.     'empty
  163.     #f)))
  164.  
  165. (define-analyzer 'name
  166.   (lambda (exp env ret?)
  167.     ;; (if (node-ref node 'lexical) #t 'empty)
  168.     ;;   ... (not (generated? exp)) ugh ...
  169.     #t))
  170.  
  171. (define-analyzer 'quote
  172.   (lambda (exp env ret?)
  173.     (if (require "repeatable quotation" #f
  174.       (simple-literal? (cadr exp)))
  175.     'empty
  176.     #f)))
  177.  
  178. (define-analyzer 'lambda
  179.   (lambda (exp env ret?) #f))
  180.  
  181. (define-analyzer 'letrec
  182.   (lambda (exp env ret?) #f))
  183.  
  184. (define-analyzer 'set!
  185.   (lambda (exp env ret?)
  186.     (simple? (caddr exp) env no-ret)))
  187.  
  188. (define-analyzer 'loophole
  189.   (lambda (exp env ret?)
  190.     (simple? (caddr exp) env ret?)))
  191.  
  192. ; Can't always fully in-line things like (lambda (a b c) (if a b c))
  193.  
  194. (define-analyzer 'if
  195.   (lambda (exp env ret?)
  196.     (and (eq? (simple? (caddr exp) env ret?) 'empty)
  197.      (eq? (simple? (cadddr exp) env ret?) 'empty)
  198.      (simple? (cadr exp) env no-ret))))
  199.  
  200. (define-analyzer 'begin
  201.   (lambda (exp env ret?)
  202.     (let loop ((exps (cdr exp)))
  203.       (if (null? (cdr exps))
  204.       (if (simple? (car exps) env ret?) #t #f)
  205.       (and (simple? (car exps) env no-ret)
  206.            (loop (cdr exps)))))))
  207.  
  208. (define-analyzer 'call
  209.   (lambda (exp env ret?)
  210.     ;; Retry transforming calls in hopes of finding procedures that
  211.     ;; have become integrable as a result of the ongoing analysis of
  212.     ;; this package.
  213.     (let ((proc (car exp)))
  214.       (if (name-node? proc)
  215.       (let* ((node (make-node (get-operator 'call) exp))
  216.          (new-node (maybe-transform-call proc node env)))
  217.         (if (eq? new-node node)
  218.         (really-simple-call? exp env ret?)
  219.         (simple? (expand new-node env) env ret?)))
  220.       (really-simple-call? exp env ret?)))))
  221.  
  222. (define (really-simple-call? exp env ret?)
  223.   (let ((proc (car exp)))
  224.     (and (require "non-local non-tail call" proc
  225.        (or (and ret? (simple? proc env no-ret))    ;tail calls are ok
  226.            (lexical-node? proc)))        ;so are calls to arguments
  227.      (simple-list? exp env))))
  228.  
  229. (define (lexical-node? node)
  230.   (not (node-ref node 'binding)))
  231.  
  232. (define no-ret #f)
  233.  
  234. (define ret #t)
  235.  
  236. (define (simple-literal? x) ;Things that TRANSPORT won't copy.
  237.   (or (integer? x)
  238.       (boolean? x)
  239.       (null? x)
  240.       (char? x)
  241.       (symbol? x)))
  242.  
  243.  
  244. ; --------------------
  245. ; Once we know that we want something to be inlined, the following things
  246. ; actually makes use of the fact.  For procedures for which all
  247. ; arguments can be substituted unconditionally, we make a transform
  248. ; (a macro, really) that performs the substitution.
  249.  
  250. (define (make-inline-transform node type p name)
  251.   (let* ((free (free-top-level-variables node))
  252.      (form (make-substitution-template node p free))
  253.      (aux-names (map (lambda (free)
  254.                (do ((free free (generated-parent-name free)))
  255.                    ((not (generated? free)) free)))
  256.              free)))
  257.     (make-transform (inline-transform form aux-names)
  258.             p            ;env ?
  259.             type
  260.             `(inline-transform ',form ',aux-names)
  261.             name)))
  262.  
  263. ; Create something that can be passed to SUBSTITUTE.  Must be valid as
  264. ; a quotation.
  265.  
  266. (define (make-substitution-template node p free)
  267.   (let ((env (package->environment p)))
  268.     (clean-node node
  269.         (map (lambda (free)
  270.                (cons free (name->qualified free env)))
  271.              free))))
  272.  
  273. ; This routine is obligated to return an S-expression.
  274. ; It's better not to rely on the constancy of node id's, so 
  275. ; the output language is a sort of quasi-Scheme.  Any form that's a list
  276. ; has an operator name in its car.
  277.  
  278. (define (clean-node node env)
  279.   (cond ((name-node? node)
  280.      (clean-lookup env (node-form node)))
  281.     ((quote-node? node)
  282.      `(quote ,(cadr (node-form node))))
  283.     ((lambda-node? node)
  284.      (clean-lambda node env))
  285.     ((call-node? node)
  286.      (cons 'call
  287.            (map (lambda (node) (clean-node node env))
  288.             (node-form node))))
  289.     ((loophole-node? node)        ;Uck
  290.      (let ((args (cdr (node-form node))))
  291.        `(loophole ,(schemify (car args))
  292.               ,(clean-node (cadr args) env))))
  293.     ;; LETREC had better not occur, since we ain't prepared for it
  294.     ((pair? (node-form node))
  295.      (cons (operator-name (node-operator node))
  296.            (map (lambda (subnode)
  297.               (clean-node subnode env))
  298.             (cdr (node-form node)))))
  299.     (else (node-form node))))    ;literal
  300.  
  301. (define quote-node? (node-predicate 'quote))
  302. (define call-node? (node-predicate 'call))
  303.  
  304.  
  305. (define (clean-lambda node env)
  306.   (let* ((exp (node-form node))
  307.      (formals (cadr exp))
  308.      (env (append (map (lambda (name)
  309.                  (cons name
  310.                    (unused-name env name)))
  311.                (normalize-formals formals))
  312.               env)))
  313.     `(lambda ,(let recur ((foo formals))
  314.         (cond ((name? foo) (clean-lookup env foo))
  315.               ((pair? foo)
  316.                (cons (recur (car foo))
  317.                  (recur (cdr foo))))
  318.               (else foo)))
  319.        ,(clean-node (caddr exp) env))))
  320.  
  321. (define (clean-lookup env name)
  322.   (cdr (assq name env)))        ;Must be there.
  323.   
  324. ; I'm aware that this is pedantic.
  325.  
  326. (define (unused-name env name)
  327.   (let ((sym (if (generated? name)
  328.          (generated-symbol name)
  329.          name)))
  330.     (do ((i 0 (+ i 1))
  331.      (name sym
  332.            (string->symbol (string-append (symbol->string sym)
  333.                           (number->string i)))))
  334.     ((not (assq name env)) name))))
  335.       
  336.  
  337. (define (free-top-level-variables node)
  338.   (let recur ((node node) (vars '()))
  339.     (cond ((quote-node? node) vars)
  340.       ((name-node? node)
  341.        (if (node-ref node 'binding)
  342.            (let ((var (node-form node)))
  343.          (if (memq var vars) vars (cons var vars)))
  344.            vars))
  345.       ;; lambda, letrec shouldn't occur
  346.       (else
  347.        (let ((form (node-form node)))
  348.          (if (pair? form)
  349.          (reduce (lambda (node vars)
  350.                (if (node? node)
  351.                    (recur node vars)
  352.                    vars))
  353.              vars
  354.              (if (call-node? node)
  355.                  form
  356.                  (cdr form)))
  357.          vars))))))
  358.  
  359.  
  360. ; --------------------
  361. ; debugging hack
  362.  
  363. (define (require reason id x)
  364.   (if (and *debug?* (not x))
  365.       (begin (write id)
  366.          (display " lost because ")
  367.          (display reason)
  368.          (display " failed")
  369.          (newline)))
  370.   x)
  371.  
  372. (define *debug?* #f)
  373.  
  374. ; utility
  375.  
  376. (define (package-lookup-type p name)
  377.   (let ((probe (package-lookup p name)))
  378.     (if (binding? probe)
  379.     (binding-type probe)
  380.     #f)))
  381.  
  382. ; --------------------
  383.     
  384.  
  385. ;(define (foo f p)
  386. ;  (analyze-forms (alpha-forms (scan-file f p) p)))
  387. ;
  388. ;
  389. ;(define (tst e p)
  390. ;  (inlinable-rhs? (alpha e p) #f))
  391. ;
  392. ;(define b (make-compiler-base))
  393. ;
  394. ;(define p (make-simple-package (list b) eval #f))
  395. ;
  396. ;; (define b-stuff (alpha-structure b))
  397. ;
  398.